home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / spool100.arc / SPOOLER.PAS < prev    next >
Pascal/Delphi Source File  |  1990-04-29  |  12KB  |  405 lines
  1. { =============================================================================
  2.  
  3.                          SPOOLER ver. 1.0 del 21/04/90
  4.  
  5.                             Paolo Ruggieri - Genova
  6.  
  7.                    Una unit di PUBBLICO DOMINIO per accedere
  8.                     ai servizi di PRINT.COM (spooler MS-DOS)
  9.                  dai programmi in TurboPascal 4.0 o successivi.
  10.  
  11.   Per commenti, suggerimenti e segnalazioni di bugs sono raggiungibile
  12.   via modem presso:
  13.  
  14.                     Utente MC4479 su MC-Link (300/1200/2400 baud, 8-N-1
  15.                                               06-4510211/4513182/4180440
  16.                                               NUA Itapac 26500140)
  17.  
  18.                     o attraverso l'area (echo Italia) TurboPascal presso
  19.                     vari BBS della rete Fido.
  20.  
  21. ============================================================================= }
  22.  
  23. {$R-,S-,V-}
  24. unit Spooler;
  25.  
  26. interface
  27.  
  28. uses Dos;
  29.  
  30. const MAX_ENTRY_LEN     = 63;    { Massima lunghezza path del file da stampare }
  31.       MAX_SPOOLER_ENTRY = 32;    { Numero masssimo di files in coda }
  32.       MIN_DOS_VERSION   = $0300; { Minima versione Dos richiesta. }
  33.  
  34.       SPOOLER_INSTALLED           = $FF;
  35.       SPOOLER_NOT_INSTALLED       = $00;
  36.       SPOOLER_CANNOT_BE_INSTALLED = $01;
  37.  
  38.       QUEUE_FULL                  = $08;
  39.  
  40. type EntryType  = string[MAX_ENTRY_LEN];
  41.      QueueType  = array[1..MAX_SPOOLER_ENTRY] of EntryType;
  42.  
  43. var SpoolerResult : word;
  44.  
  45. { ===================== FUNZIONI e PROCEDURE disponibili ==================== }
  46.  
  47. function SpoolerStatus : word;
  48. procedure SubmitFileS(WildCString : EntryType; var Queue : QueueType);
  49. procedure CancelFiles(WildCString : EntryType);
  50. procedure CancelAllFiles;
  51. procedure ListQueue(var Queue : QueueType);
  52.  
  53. {  CancelFiles e CancelAllFiles non eliminano i files da disco ma dalla coda  }
  54.  
  55. { =========================================================================== }
  56.  
  57. implementation
  58.  
  59. const NUL               = #0;
  60.       MAX_ASCIIZ_LEN    = 64;
  61.  
  62.  
  63. type ASCIIZType       = array[1..MAX_ASCIIZ_LEN] of char;
  64.      ASCIIZQueueType  = array[1..MAX_SPOOLER_ENTRY] of ASCIIZType;
  65.      SubmitPacketType = record
  66.                           LevelCode      : byte;
  67.                           FileStringAddr : pointer;
  68.                         end;
  69.      cset             = set of char;
  70. {$IFDEF VER40}
  71.      PathStr          = string[79];
  72. {$ENDIF}
  73.  
  74. var regs            : Registers;
  75.     HeapFSave       : pointer;
  76.  
  77. {$IFDEF VER40}
  78.     DosVersion      : word;
  79. {$ENDIF}
  80.  
  81. { -----------------------------------------------------------------------------
  82.     InitializeRegisters - inizializza a zero il record regs
  83.  
  84.     (l'ho introdotta in seguito ad alcuni problemi in SubmitFile)
  85. ----------------------------------------------------------------------------- }
  86. procedure InitializeRegisters;
  87.  
  88.   begin
  89.     FillChar(regs,SizeOf(regs),NUL);
  90.   end;
  91.  
  92. { -----------------------------------------------------------------------------
  93.     CarryFlag - ritorna true se il carry flag e` settato
  94. ----------------------------------------------------------------------------- }
  95. function CarryFlag : boolean;
  96.  
  97.   begin
  98.     if ((regs.flags and FCarry) = FCarry) then CarryFlag := true
  99.      else                                      CarryFlag := false;
  100.   end;
  101.  
  102. { -----------------------------------------------------------------------------
  103.     Str_to_ASCIIZ - converte una stringa TP in una stringa ASCIIZ
  104. ----------------------------------------------------------------------------- }
  105. procedure Str_to_ASCIIZ(StrTP : EntryType; var ASCIIZ : ASCIIZType);
  106.  
  107. var i : byte;
  108.  
  109.   begin
  110.     for i:=1 to length(StrTP) do ASCIIZ[i] := StrTP[i];
  111.     ASCIIZ[i+1] := NUL;
  112.   end;
  113.  
  114. { -----------------------------------------------------------------------------
  115.     ASCIIZ_to_Str - converte una stringa ASCIIZ in una stringa TP
  116. ----------------------------------------------------------------------------- }
  117. procedure ASCIIZ_to_Str(ASCIIZ : ASCIIZType; var StrTP : EntryType);
  118.  
  119. var i : byte;
  120.  
  121.   begin
  122.     i := 1;
  123.     StrTP := '';
  124.  
  125.     while (ASCIIZ[i]<>NUL) do
  126.       begin
  127.         StrTP := StrTP + ASCIIZ[i];
  128.         inc(i)
  129.       end;
  130.   end;
  131.  
  132. { -----------------------------------------------------------------------------
  133.     Last - restituisce la posizione dell'ultima occorenza di un carattere
  134.            di un set
  135. ----------------------------------------------------------------------------- }
  136. function Last(s : string; c : cset) : byte;
  137.  
  138. var i,
  139.     p  : byte;
  140.  
  141.   begin
  142.     p := 0;
  143.     for i:=length(s) downto 1 do if ((s[i] in c) and (p=0)) then p := i;
  144.     Last := p;
  145.   end;
  146.  
  147. {$IFDEF VER40}
  148. { -----------------------------------------------------------------------------
  149.     FExpand - espande un path in un nome file pienamente qualificato
  150. ----------------------------------------------------------------------------- }
  151. function FExpand(path : PathStr) : PathStr;
  152.  
  153. var i  : byte;
  154.     p,
  155.     fn,
  156.     cp : PathStr;
  157.  
  158.   begin
  159. {$I-}
  160.     GetDir(0,cp); if (IOResult<>0) then
  161.                     begin
  162.                       FExpand := '';
  163.                       exit;
  164.                     end;
  165.  
  166.     i  := Last(path,[':','\']);
  167.     p  := copy(path,1,i);
  168.     fn := copy(path,i+1,length(path)-length(p));
  169.     if (p[length(p)]='\') then p[0] := chr(ord(p[0])-1);
  170.  
  171.     p := '';
  172.  
  173.     ChDir(p); if (IOResult=0) then
  174.                 begin
  175.                   GetDir(0,p);
  176.                   if (IOResult=0) then p := p + '\';
  177.                 end;
  178.  
  179.     ChDir(cp);
  180. {$I+}
  181.     FExpand := p + fn;
  182.   end;
  183. {$ENDIF}
  184.  
  185. { -----------------------------------------------------------------------------
  186.     SpoolerStatus - controlla se PRINT e` installato
  187.  
  188.       Ritorna: SPOOLER_INSTALLED           se e` INSTALLATO
  189.                SPOOLER_NOT_INSTALLED       se NON e` INSTALLATO e
  190.                                            puo` essere installato
  191.                SPOOLER_CANNOT_BE_INSTALLED se NON e` INSTALLATO e
  192.                                            NON PUO` essere installato
  193. ----------------------------------------------------------------------------- }
  194. function SpoolerStatus : word;
  195.  
  196.   begin
  197.     if (DosVersion<MIN_DOS_VERSION) then
  198.       begin
  199.         SpoolerResult := SPOOLER_CANNOT_BE_INSTALLED;
  200.         SpoolerStatus := SpoolerResult;
  201.         exit;
  202.       end;
  203.  
  204.     InitializeRegisters;
  205.  
  206.     regs.ax := $0100;
  207.     Intr($2F,regs);
  208.  
  209.     if (regs.al=SPOOLER_INSTALLED) then SpoolerResult := 0
  210.      else                               SpoolerResult := regs.al;
  211.  
  212.     SpoolerStatus := regs.al;
  213.   end;
  214.  
  215. { -----------------------------------------------------------------------------
  216.     SubmitFile - accoda FileString (singolo file) per la stampa
  217.  
  218.                  Simula: PRINT FileString [/P]
  219. ----------------------------------------------------------------------------- }
  220. procedure SubmitFile(FileString : EntryType);
  221.  
  222. var SubmitPacket : SubmitPacketType;
  223.     ASCIIZ       : ASCIIZType;
  224.  
  225.   begin
  226.     if (SpoolerStatus<>SPOOLER_INSTALLED) then exit;
  227.  
  228.     Str_to_ASCIIZ(FExpand(FileString),ASCIIZ);
  229.     SubmitPacket.LevelCode      := 0;
  230.     SubmitPacket.FileStringAddr := addr(ASCIIZ);
  231.  
  232.     InitializeRegisters;
  233.  
  234.     regs.ax := $0101;
  235.     regs.ds := Seg(SubmitPacket);
  236.     regs.dx := Ofs(SubmitPacket);
  237.     Intr($2F,regs);
  238.  
  239.     if  CarryFlag then SpoolerResult := regs.ax
  240.                   else SpoolerResult := 0;
  241.   end;
  242.  
  243. { -----------------------------------------------------------------------------
  244.     SubmitFileS - accoda per la stampa uno o piu` files identificati
  245.                   da WildCString (puo` contenere '?' e '*')
  246.  
  247.                   Simula: PRINT WildCString [/P]
  248. ----------------------------------------------------------------------------- }
  249. procedure SubmitFileS(WildCString : EntryType; var Queue : QueueType);
  250.  
  251. var SearchInfo : SearchRec;
  252.     dir        : PathStr;
  253.     FileString : EntryType;
  254.     i          : byte;
  255.  
  256.   begin
  257.     FillChar(Queue,SizeOf(Queue),NUL);
  258.  
  259.     dir := copy(WildCString,1,Last(WildCString,[':','\']));
  260.     i := 0;
  261.  
  262.     FindFirst(WildCString,Archive,SearchInfo);
  263.  
  264.     while (DosError=0) do
  265.       begin
  266.         FileString := dir + SearchInfo.Name;
  267.         SubmitFile(FileString);
  268.         if (SpoolerResult<>0) then exit;
  269.         inc(i);
  270.         Queue[i] := FileString;
  271.         FindNext(SearchInfo);
  272.       end;
  273.     SpoolerResult := 0;
  274.   end;
  275.  
  276. { -----------------------------------------------------------------------------
  277.     CancelFiles - toglie dalla coda uno o piu` files identificati
  278.                   da WildCString (puo` contenere '?' e '*')
  279.  
  280.                   Simula: PRINT WildCString [/C]
  281.                   (anche se PRINT /C non supporta le Wild Cards)
  282. ----------------------------------------------------------------------------- }
  283. procedure CancelFiles(WildCString : EntryType);
  284.  
  285. var ASCIIZ  : ASCIIZType;
  286.     SStatus : word;
  287.  
  288.   begin
  289.     if (SpoolerStatus<>SPOOLER_INSTALLED) then exit;
  290.  
  291.     Str_to_ASCIIZ(FExpand(WildCString),ASCIIZ);
  292.  
  293.     InitializeRegisters;
  294.  
  295.     regs.ax := $0102;
  296.     regs.ds := Seg(ASCIIZ);
  297.     regs.dx := Ofs(ASCIIZ);
  298.     Intr($2F,regs);
  299.  
  300.     if  CarryFlag then SpoolerResult := regs.ax
  301.                   else SpoolerResult := 0;
  302.   end;
  303.  
  304. { -----------------------------------------------------------------------------
  305.     CancelAllFiles - toglie dalla coda tutti i files
  306.  
  307.                   Simula: PRINT /T
  308. ----------------------------------------------------------------------------- }
  309. procedure CancelAllFiles;
  310.  
  311.   begin
  312.     if (SpoolerStatus<>SPOOLER_INSTALLED) then exit;
  313.  
  314.     InitializeRegisters;
  315.  
  316.     regs.ax := $0103;
  317.     Intr($2F,regs);
  318.  
  319.     if  CarryFlag then SpoolerResult := regs.ax
  320.                   else SpoolerResult := 0;
  321.   end;
  322.  
  323. { -----------------------------------------------------------------------------
  324.     HeapFunc - richiamata dallo Heap Manager se si verifica un errore di
  325.                allocazione; ritorna 1 cosi` New ritorna nil se non e` possibile
  326.                allocare la memoria richesta
  327. ----------------------------------------------------------------------------- }
  328. {$F+}
  329. function HeapFunc(dim : word) : integer;
  330.  
  331.   begin
  332.     HeapFunc := 1;
  333.   end;
  334. {$F-}
  335.  
  336. { -----------------------------------------------------------------------------
  337.     ListQueue - restituisce la lista dei files in stampa (il 1^)
  338.                 e in coda (gli altri)
  339.  
  340.                 Simula: PRINT
  341. ----------------------------------------------------------------------------- }
  342. procedure ListQueue(var Queue : QueueType);
  343.  
  344. var ASCIIZ : ^ASCIIZQueueType;
  345.     i      : byte;
  346.  
  347.   begin
  348.     if (SpoolerStatus<>SPOOLER_INSTALLED) then exit;
  349.  
  350.     InitializeRegisters;
  351.  
  352.     FillChar(Queue,SizeOf(Queue),NUL);
  353.  
  354.     HeapFSave := HeapError;
  355.     HeapError := @HeapFunc;
  356.     new(ASCIIZ);
  357.     HeapError := HeapFSave;
  358.     if (ASCIIZ=nil) then exit;
  359.  
  360.     regs.ax := $0104;
  361.     Intr($2F,regs);
  362.  
  363.     if  CarryFlag then begin
  364.                          SpoolerResult := regs.ax;
  365.                          exit;
  366.                        end
  367.                   else SpoolerResult := 0;
  368.  
  369.     move(ptr(regs.ds,regs.si)^,ASCIIZ^,sizeof(ASCIIZ^));
  370.  
  371.     InitializeRegisters;
  372.  
  373.     regs.ax := $0105;
  374.     Intr($2F,regs);
  375.  
  376.     if  CarryFlag then begin
  377.                          SpoolerResult := regs.ax;
  378.                          exit;
  379.                        end
  380.                   else SpoolerResult := 0;
  381.  
  382.     i := 0;
  383.     repeat
  384.       inc(i);
  385.       ASCIIZ_to_Str(ASCIIZ^[i],Queue[i]);
  386.     until ((ASCIIZ^[i]=NUL) or (i=MAX_SPOOLER_ENTRY));
  387.  
  388.     dispose(ASCIIZ);
  389.   end;
  390.  
  391. { -----------------------------------------------------------------------------
  392.     SPOOLER UNIT - inizializzazione
  393. ----------------------------------------------------------------------------- }
  394. begin
  395.   InitializeRegisters;
  396.   SpoolerResult := 0;
  397.  
  398. {$IFDEF VER40}
  399.   regs.ax := $3000;
  400.   MsDos(regs);
  401.   if (regs.al=0) then DosVersion := $0100
  402.                   else DosVersion := regs.ax;
  403. {$ENDIF}
  404. end.
  405.